home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclLink.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  12.4 KB  |  424 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclLink.c --
  3.  *
  4.  *    This file implements linked variables (a C variable that is
  5.  *    tied to a Tcl variable).  The idea of linked variables was
  6.  *    first suggested by Andreas Stolcke and this implementation is
  7.  *    based heavily on a prototype implementation provided by
  8.  *    him.
  9.  *
  10.  * Copyright (c) 1993 The Regents of the University of California.
  11.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  *
  16.  * SCCS: @(#) tclLink.c 1.15 97/01/21 21:51:42
  17.  */
  18.  
  19. #include "tclInt.h"
  20.  
  21. /*
  22.  * For each linked variable there is a data structure of the following
  23.  * type, which describes the link and is the clientData for the trace
  24.  * set on the Tcl variable.
  25.  */
  26.  
  27. typedef struct Link {
  28.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  29.     char *varName;        /* Name of variable (must be global).  This
  30.                  * is needed during trace callbacks, since
  31.                  * the actual variable may be aliased at
  32.                  * that time via upvar. */
  33.     char *addr;            /* Location of C variable. */
  34.     int type;            /* Type of link (TCL_LINK_INT, etc.). */
  35.     union {
  36.     int i;
  37.     double d;
  38.     } lastValue;        /* Last known value of C variable;  used to
  39.                  * avoid string conversions. */
  40.     int flags;            /* Miscellaneous one-bit values;  see below
  41.                  * for definitions. */
  42. } Link;
  43.  
  44. /*
  45.  * Definitions for flag bits:
  46.  * LINK_READ_ONLY -        1 means errors should be generated if Tcl
  47.  *                script attempts to write variable.
  48.  * LINK_BEING_UPDATED -        1 means that a call to Tcl_UpdateLinkedVar
  49.  *                is in progress for this variable, so
  50.  *                trace callbacks on the variable should
  51.  *                be ignored.
  52.  */
  53.  
  54. #define LINK_READ_ONLY        1
  55. #define LINK_BEING_UPDATED    2
  56.  
  57. /*
  58.  * Forward references to procedures defined later in this file:
  59.  */
  60.  
  61. static char *        LinkTraceProc _ANSI_ARGS_((ClientData clientData,
  62.                 Tcl_Interp *interp, char *name1, char *name2,
  63.                 int flags));
  64. static char *        StringValue _ANSI_ARGS_((Link *linkPtr,
  65.                 char *buffer));
  66.  
  67. /*
  68.  *----------------------------------------------------------------------
  69.  *
  70.  * Tcl_LinkVar --
  71.  *
  72.  *    Link a C variable to a Tcl variable so that changes to either
  73.  *    one causes the other to change.
  74.  *
  75.  * Results:
  76.  *    The return value is TCL_OK if everything went well or TCL_ERROR
  77.  *    if an error occurred (interp->result is also set after errors).
  78.  *
  79.  * Side effects:
  80.  *    The value at *addr is linked to the Tcl variable "varName",
  81.  *    using "type" to convert between string values for Tcl and
  82.  *    binary values for *addr.
  83.  *
  84.  *----------------------------------------------------------------------
  85.  */
  86.  
  87. int
  88. Tcl_LinkVar(interp, varName, addr, type)
  89.     Tcl_Interp *interp;        /* Interpreter in which varName exists. */
  90.     char *varName;        /* Name of a global variable in interp. */
  91.     char *addr;            /* Address of a C variable to be linked
  92.                  * to varName. */
  93.     int type;            /* Type of C variable: TCL_LINK_INT, etc. 
  94.                  * Also may have TCL_LINK_READ_ONLY
  95.                  * OR'ed in. */
  96. {
  97.     Link *linkPtr;
  98.     char buffer[TCL_DOUBLE_SPACE];
  99.     int code;
  100.  
  101.     linkPtr = (Link *) ckalloc(sizeof(Link));
  102.     linkPtr->interp = interp;
  103.     linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
  104.     strcpy(linkPtr->varName, varName);
  105.     linkPtr->addr = addr;
  106.     linkPtr->type = type & ~TCL_LINK_READ_ONLY;
  107.     if (type & TCL_LINK_READ_ONLY) {
  108.     linkPtr->flags = LINK_READ_ONLY;
  109.     } else {
  110.     linkPtr->flags = 0;
  111.     }
  112.     if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
  113.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
  114.     ckfree(linkPtr->varName);
  115.     ckfree((char *) linkPtr);
  116.     return TCL_ERROR;
  117.     }
  118.     code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
  119.         |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
  120.         (ClientData) linkPtr);
  121.     if (code != TCL_OK) {
  122.     ckfree(linkPtr->varName);
  123.     ckfree((char *) linkPtr);
  124.     }
  125.     return code;
  126. }
  127.  
  128. /*
  129.  *----------------------------------------------------------------------
  130.  *
  131.  * Tcl_UnlinkVar --
  132.  *
  133.  *    Destroy the link between a Tcl variable and a C variable.
  134.  *
  135.  * Results:
  136.  *    None.
  137.  *
  138.  * Side effects:
  139.  *    If "varName" was previously linked to a C variable, the link
  140.  *    is broken to make the variable independent.  If there was no
  141.  *    previous link for "varName" then nothing happens.
  142.  *
  143.  *----------------------------------------------------------------------
  144.  */
  145.  
  146. void
  147. Tcl_UnlinkVar(interp, varName)
  148.     Tcl_Interp *interp;        /* Interpreter containing variable to unlink. */
  149.     char *varName;        /* Global variable in interp to unlink. */
  150. {
  151.     Link *linkPtr;
  152.  
  153.     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
  154.         LinkTraceProc, (ClientData) NULL);
  155.     if (linkPtr == NULL) {
  156.     return;
  157.     }
  158.     Tcl_UntraceVar(interp, varName,
  159.         TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  160.         LinkTraceProc, (ClientData) linkPtr);
  161.     ckfree(linkPtr->varName);
  162.     ckfree((char *) linkPtr);
  163. }
  164.  
  165. /*
  166.  *----------------------------------------------------------------------
  167.  *
  168.  * Tcl_UpdateLinkedVar --
  169.  *
  170.  *    This procedure is invoked after a linked variable has been
  171.  *    changed by C code.  It updates the Tcl variable so that
  172.  *    traces on the variable will trigger.
  173.  *
  174.  * Results:
  175.  *    None.
  176.  *
  177.  * Side effects:
  178.  *    The Tcl variable "varName" is updated from its C value,
  179.  *    causing traces on the variable to trigger.
  180.  *
  181.  *----------------------------------------------------------------------
  182.  */
  183.  
  184. void
  185. Tcl_UpdateLinkedVar(interp, varName)
  186.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  187.     char *varName;        /* Name of global variable that is linked. */
  188. {
  189.     Link *linkPtr;
  190.     char buffer[TCL_DOUBLE_SPACE];
  191.     int savedFlag;
  192.  
  193.     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
  194.         LinkTraceProc, (ClientData) NULL);
  195.     if (linkPtr == NULL) {
  196.     return;
  197.     }
  198.     savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
  199.     linkPtr->flags |= LINK_BEING_UPDATED;
  200.     Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
  201.         TCL_GLOBAL_ONLY);
  202.     linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
  203. }
  204.  
  205. /*
  206.  *----------------------------------------------------------------------
  207.  *
  208.  * LinkTraceProc --
  209.  *
  210.  *    This procedure is invoked when a linked Tcl variable is read,
  211.  *    written, or unset from Tcl.  It's responsible for keeping the
  212.  *    C variable in sync with the Tcl variable.
  213.  *
  214.  * Results:
  215.  *    If all goes well, NULL is returned; otherwise an error message
  216.  *    is returned.
  217.  *
  218.  * Side effects:
  219.  *    The C variable may be updated to make it consistent with the
  220.  *    Tcl variable, or the Tcl variable may be overwritten to reject
  221.  *    a modification.
  222.  *
  223.  *----------------------------------------------------------------------
  224.  */
  225.  
  226. static char *
  227. LinkTraceProc(clientData, interp, name1, name2, flags)
  228.     ClientData clientData;    /* Contains information about the link. */
  229.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  230.     char *name1;        /* First part of variable name. */
  231.     char *name2;        /* Second part of variable name. */
  232.     int flags;            /* Miscellaneous additional information. */
  233. {
  234.     Link *linkPtr = (Link *) clientData;
  235.     int changed;
  236.     char buffer[TCL_DOUBLE_SPACE];
  237.     char *value, **pp;
  238.     Tcl_DString savedResult;
  239.  
  240.     /*
  241.      * If the variable is being unset, then just re-create it (with a
  242.      * trace) unless the whole interpreter is going away.
  243.      */
  244.  
  245.     if (flags & TCL_TRACE_UNSETS) {
  246.     if (flags & TCL_INTERP_DESTROYED) {
  247.         ckfree(linkPtr->varName);
  248.         ckfree((char *) linkPtr);
  249.     } else if (flags & TCL_TRACE_DESTROYED) {
  250.         Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
  251.             TCL_GLOBAL_ONLY);
  252.         Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY
  253.             |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  254.             LinkTraceProc, (ClientData) linkPtr);
  255.     }
  256.     return NULL;
  257.     }
  258.  
  259.     /*
  260.      * If we were invoked because of a call to Tcl_UpdateLinkedVar, then
  261.      * don't do anything at all.  In particular, we don't want to get
  262.      * upset that the variable is being modified, even if it is
  263.      * supposed to be read-only.
  264.      */
  265.  
  266.     if (linkPtr->flags & LINK_BEING_UPDATED) {
  267.     return NULL;
  268.     }
  269.  
  270.     /*
  271.      * For read accesses, update the Tcl variable if the C variable
  272.      * has changed since the last time we updated the Tcl variable.
  273.      */
  274.  
  275.     if (flags & TCL_TRACE_READS) {
  276.     switch (linkPtr->type) {
  277.         case TCL_LINK_INT:
  278.         case TCL_LINK_BOOLEAN:
  279.         changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
  280.         break;
  281.         case TCL_LINK_DOUBLE:
  282.         changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
  283.         break;
  284.         case TCL_LINK_STRING:
  285.         changed = 1;
  286.         break;
  287.         default:
  288.         return "internal error: bad linked variable type";
  289.     }
  290.     if (changed) {
  291.         Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
  292.             TCL_GLOBAL_ONLY);
  293.     }
  294.     return NULL;
  295.     }
  296.  
  297.     /*
  298.      * For writes, first make sure that the variable is writable.  Then
  299.      * convert the Tcl value to C if possible.  If the variable isn't
  300.      * writable or can't be converted, then restore the varaible's old
  301.      * value and return an error.  Another tricky thing: we have to save
  302.      * and restore the interpreter's result, since the variable access
  303.      * could occur when the result has been partially set.
  304.      */
  305.  
  306.     if (linkPtr->flags & LINK_READ_ONLY) {
  307.     Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
  308.         TCL_GLOBAL_ONLY);
  309.     return "linked variable is read-only";
  310.     }
  311.     value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY);
  312.     if (value == NULL) {
  313.     /*
  314.      * This shouldn't ever happen.
  315.      */
  316.     return "internal error: linked variable couldn't be read";
  317.     }
  318.     Tcl_DStringInit(&savedResult);
  319.     Tcl_DStringAppend(&savedResult, interp->result, -1);
  320.     Tcl_ResetResult(interp);
  321.     switch (linkPtr->type) {
  322.     case TCL_LINK_INT:
  323.         if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
  324.         Tcl_DStringResult(interp, &savedResult);
  325.         Tcl_SetVar(interp, linkPtr->varName,
  326.             StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
  327.         return "variable must have integer value";
  328.         }
  329.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  330.         break;
  331.     case TCL_LINK_DOUBLE:
  332.         if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
  333.             != TCL_OK) {
  334.         Tcl_DStringResult(interp, &savedResult);
  335.         Tcl_SetVar(interp, linkPtr->varName,
  336.             StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
  337.         return "variable must have real value";
  338.         }
  339.         *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
  340.         break;
  341.     case TCL_LINK_BOOLEAN:
  342.         if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
  343.             != TCL_OK) {
  344.         Tcl_DStringResult(interp, &savedResult);
  345.         Tcl_SetVar(interp, linkPtr->varName,
  346.             StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
  347.         return "variable must have boolean value";
  348.         }
  349.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  350.         break;
  351.     case TCL_LINK_STRING:
  352.         pp = (char **)(linkPtr->addr);
  353.         if (*pp != NULL) {
  354.         ckfree(*pp);
  355.         }
  356.         *pp = (char *) ckalloc((unsigned) (strlen(value) + 1));
  357.         strcpy(*pp, value);
  358.         break;
  359.     default:
  360.         return "internal error: bad linked variable type";
  361.     }
  362.     Tcl_DStringResult(interp, &savedResult);
  363.     return NULL;
  364. }
  365.  
  366. /*
  367.  *----------------------------------------------------------------------
  368.  *
  369.  * StringValue --
  370.  *
  371.  *    Converts the value of a C variable to a string for use in a
  372.  *    Tcl variable to which it is linked.
  373.  *
  374.  * Results:
  375.  *    The return value is a pointer
  376.  to a string that represents
  377.  *    the value of the C variable given by linkPtr.
  378.  *
  379.  * Side effects:
  380.  *    None.
  381.  *
  382.  *----------------------------------------------------------------------
  383.  */
  384.  
  385. static char *
  386. StringValue(linkPtr, buffer)
  387.     Link *linkPtr;        /* Structure describing linked variable. */
  388.     char *buffer;        /* Small buffer to use for converting
  389.                  * values.  Must have TCL_DOUBLE_SPACE
  390.                  * bytes or more. */
  391. {
  392.     char *p;
  393.  
  394.     switch (linkPtr->type) {
  395.     case TCL_LINK_INT:
  396.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  397.         TclFormatInt(buffer, linkPtr->lastValue.i);
  398.         return buffer;
  399.     case TCL_LINK_DOUBLE:
  400.         linkPtr->lastValue.d = *(double *)(linkPtr->addr);
  401.         Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer);
  402.         return buffer;
  403.     case TCL_LINK_BOOLEAN:
  404.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  405.         if (linkPtr->lastValue.i != 0) {
  406.         return "1";
  407.         }
  408.         return "0";
  409.     case TCL_LINK_STRING:
  410.         p = *(char **)(linkPtr->addr);
  411.         if (p == NULL) {
  412.         return "NULL";
  413.         }
  414.         return p;
  415.     }
  416.  
  417.     /*
  418.      * This code only gets executed if the link type is unknown
  419.      * (shouldn't ever happen).
  420.      */
  421.  
  422.     return "??";
  423. }
  424.